home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PRUS101 / FTVPRINT.PAS < prev    next >
Pascal/Delphi Source File  |  1994-12-20  |  9KB  |  488 lines

  1. unit FTVPRINT;
  2.  
  3.  { FIDO unit to use different Printer with ONE Unit + Driver
  4.    running under Turbo Vision
  5.  (*************************************************************************)
  6.  
  7.      RELEASE 1.00 - as first contained in the file PRUS???.LZH
  8.         by Matthias Tichy, 2:2440/210.14, GERMANY
  9.  
  10.            --------------------------------------------
  11.         organized for Fido's PASCAL related echoes
  12.            --------------------------------------------
  13.  
  14.      15/08/1994 to --/--/---- by Matthias Tichy, 2:2440/210.14, GERMANY
  15.  
  16.  
  17.        As far as third party copyrights are not violated this
  18.        source code is hereby placed to the public domain. Use
  19.        it whatever way you want, but use AT YOUR OWN RISK.
  20.  
  21.        In case you should modify the source rather send your
  22.        modifications to the unit's current organizer (see above for
  23.        NM address) than to spread it on your own. This will help to
  24.        keep the unit updated and grant a certain standard to all
  25.        other users as well.
  26.  
  27.        The unit is currently still under work. So it might greatly
  28.        benefit of your participation.
  29.  
  30.        Those who contributed to the following piece of source,
  31.        listed in alphabethical order:
  32.     ================================================================
  33.         Matthias Tichy ...
  34.     ================================================================
  35.        YOUR NAME WILL APPEAR HERE IF YOU CONTRIBUTE USEFUL SOURCE.
  36.  
  37.        Credits in your own programs are as welcome as unnecessary.
  38.  
  39. (***************************************************************************}
  40.  
  41. {$I FDEFINE.DEF} { Use the general include file for conditional defines and
  42.         y   common compiler directives ... }
  43.  
  44.          { ... and set the unit's specific defines aftwerwards. }
  45.  
  46. interface
  47.  
  48. uses dos, printer, msgbox;
  49.  
  50. const
  51.   FPrinter : Byte = 1;
  52.   {$ifdef English}
  53.   fxxx : array[1..1] of string = ('Printer');
  54.   {$endif}
  55.   {$ifdef German}
  56.   fxxx : array[1..1] of string = ('Drucker');
  57.   {$endif}
  58.  
  59. type
  60.   PParameter = ^TParameter;
  61.   TParameter = array[1..10] of Byte;
  62.  
  63.   PTreiber = ^TTreiber;
  64.   TTreiber = array[1..30] of Char;
  65.  
  66. var
  67.   Printer_fault : byte;
  68.   f : text;
  69.   treiber_datei : string;
  70.   Parameter : PParameter;
  71.   Treiber : PTreiber;
  72.   oldint24 : pointer;
  73.   newint24 : pointer;
  74.  
  75. procedure init;
  76. procedure done;
  77.  
  78. procedure setTDT(datei : string);
  79. function CheckTDT(datei : string) : boolean;
  80. function GetPrinter(datei :string) : string;
  81.  
  82. function getfault : byte;
  83. procedure Error(object_id, code : byte);
  84.  
  85. procedure laden(nr : byte);
  86. procedure ausgeben;
  87.  
  88. procedure printeln(text : string);
  89. procedure print(text : string);
  90. procedure cr;
  91. procedure lf;
  92. procedure ff;
  93.  
  94. procedure PrinterInit;
  95. procedure BoldOn;
  96. procedure BoldOff;
  97. procedure ItalicOn;
  98. procedure ItalicOff;
  99. procedure UnderLinedOn;
  100. procedure UnderLinedOff;
  101. procedure BreitOn;
  102. procedure BreitOff;
  103. procedure SchmalOn;
  104. procedure SchmalOff;
  105. procedure HighOn;
  106. procedure HighOff;
  107. procedure LowOn;
  108. procedure LowOff;
  109.  
  110. { allgemeine Routinen }
  111.  
  112. function FileExists(FileName: string; attr : Word) : Boolean;
  113. function getpartstring(text : string; anfang, ende : char) : string;
  114. function Byte2Str(Zahl : Byte) : string;
  115.  
  116. implementation
  117.  
  118. procedure Init;
  119.  
  120. begin
  121.   New(Parameter);
  122.   New(treiber);
  123. end;
  124.  
  125. procedure Done;
  126.  
  127. begin
  128.   Dispose(Parameter);
  129.   Dispose(Treiber);
  130. end;
  131.  
  132. procedure setTDT(datei : string);
  133.  
  134. begin
  135.   treiber_datei := datei;
  136.   if not fileExists(treiber_datei, anyfile) then error(FPrinter, 1);
  137.   Assign(f, treiber_datei);
  138. end;
  139.  
  140. function CheckTDT(datei :string) : boolean;
  141.  
  142. var dat : text;
  143.     Zeile : string;
  144.  
  145. begin
  146.   CheckTDT := false;
  147.   assign(dat, datei);
  148.   reset(dat);
  149.   readln(dat, Zeile);
  150.   if Zeile = 'TDT' then CheckTDT := true;
  151.   close(dat);
  152. end;
  153.  
  154. function GetPrinter(datei :string) : string;
  155.  
  156. var dat : text;
  157.     Zeile : string;
  158.  
  159. begin
  160.   assign(dat, datei);
  161.   reset(dat);
  162.   repeat
  163.     readln(dat, Zeile);
  164.   until copy(Zeile,1,2) = 'N)';
  165.   getPrinter := copy(Zeile, 4, length(Zeile)-4);
  166.   close(dat);
  167. end;
  168.  
  169. function getfault : byte;
  170.  
  171. begin
  172.   Printer_fault := ioresult;
  173.   if Printer_fault <> 0 then Error(FPrinter, Printer_fault);
  174.   getfault := Printer_fault;
  175. end;
  176.  
  177. procedure Error(object_id, code : Byte);
  178.  
  179. var
  180.   meldung : string;
  181.  
  182. begin
  183.   case code of
  184.     151 : meldung := 'Bitte stecken Sie den Drucker an die parallele Schnittstelle an,'+#13+
  185.                      'schalten ihn an und auf on-line';
  186.     159 : meldung := 'Das Papier ist zu Ende. Bitte füllen Sie Neues nach.';
  187.     160 : meldung := 'Der Drucker ist auf off-line. Schalten Sie ihn bitte auf on-line';
  188.     else  meldung := 'Unbekannter Drucker-Fehler Nr: '+ byte2str(code);
  189.   end;
  190.   messagebox(meldung, nil, mfOkButton);
  191. end;
  192.  
  193. procedure setparameter(index, Text : byte);
  194.  
  195. begin
  196.   Parameter^[index] := text;
  197. end;
  198.  
  199. procedure laden(nr :Byte);
  200.  
  201. var
  202.   punkt : LongInt;
  203.   buf : String;
  204.   ch : string;
  205.   dummy : string;
  206.   para : Char;
  207.   tester : boolean;
  208.   param : Byte;
  209.  
  210.   function getchar : char;
  211.  
  212.   var temp : string;
  213.       dummy : Byte;
  214.       i : Byte;
  215.       code : Integer;
  216.  
  217.   begin
  218.     buf := removeleft(') ',buf);
  219.     buf := removeright('; ',buf);
  220.     if buf = '' then
  221.       begin
  222.         getChar := #255;
  223.         exit;
  224.       end;
  225.     temp := buf;
  226.     i := 1;
  227.     while (not (temp[i] in ['#','$','n'])) and not (i>length(temp)) do inc(i);
  228.     if temp[length(temp)] <> ' ' then temp := temp + ' ';
  229.     temp := getpartstring(temp,temp[i],' ');
  230.     case temp[1] of
  231.       '#' : begin
  232.               i := 2;
  233.               if temp[length(temp)] <> ' ' then temp := temp + ' ';
  234.               val(copy(temp,2,length(temp)-2),dummy,code);
  235.               getChar := char(dummy);
  236.             end;
  237.       'n' : begin
  238.               getChar := char(parameter^[param]);
  239.               inc(param);
  240.             end;
  241.       ' ' : begin
  242.               getChar := #255;
  243.             end;
  244.     end;
  245.     i := pos(' ',buf);
  246.     buf := copy(buf, i, length(buf)-i+1);
  247.     if i = 0 then buf := '';
  248.   end;
  249.  
  250. begin
  251.   for punkt := 1 to 35 do treiber^[punkt] := #255;
  252.   param := 1;
  253.   str(nr,ch);
  254.   reset(f);
  255.   tester := false;
  256.   repeat
  257.     readln(f, buf);
  258.     dummy := buf;
  259.     buf := removeLeft(' ',buf);
  260.     buf := copy(buf, 1, pos(')',buf)-1);
  261.     if buf = ch then tester := true;
  262.     buf := dummy;
  263.   until tester = true or eof(f);
  264.   if eof(f) and not tester then
  265.     begin
  266.       writeln('Fehler in Druckertreiber bei Nr :', nr, '!!');
  267.       halt;
  268.     end;
  269.   buf := getpartstring(buf,')',';');
  270.   punkt := 1;
  271.   repeat
  272.     para := getChar;
  273.     if para <> #255 then Treiber^[punkt] := para;
  274.     inc(punkt);
  275.   until para = #255;
  276.   close(f);
  277. end;
  278.  
  279. {$I-}
  280. procedure ausgeben;
  281.  
  282. var
  283.   index : byte;
  284.  
  285. begin
  286.   getintvec($24,newint24);
  287.   setintvec($24,oldint24);
  288.   for index := 1 to 35 do if Treiber^[index] <> chr(255) then
  289.     begin
  290.       repeat;
  291.         write(lst,Treiber^[index]);
  292.       until getfault = 0;
  293.     end;
  294.   SetIntVec($24, newInt24);
  295. end;
  296.  
  297. procedure printeln(text : string);
  298.  
  299. var i : Byte;
  300.  
  301. begin
  302.   getintvec($24,newint24);
  303.   setintvec($24,oldint24);
  304.   repeat;
  305.   writeln(lst,text);
  306.   until getfault = 0;
  307.   SetIntVec($24, newInt24);
  308. end;
  309.  
  310. procedure print(Text : string);
  311.  
  312. var i : Byte;
  313.  
  314. begin
  315.   getintvec($24,newint24);
  316.   setintvec($24,oldint24);
  317.   repeat;
  318.   write(lst,text);
  319.   until getfault = 0;
  320.   SetIntVec($24, newInt24);
  321. end;
  322.  
  323. {$I+}
  324.  
  325. procedure PrinterInit;
  326.  
  327. begin
  328.   laden(1);
  329.   ausgeben;
  330. end;
  331.  
  332. procedure BoldOn;
  333.  
  334. begin
  335.   laden(2);
  336.   ausgeben;
  337. end;
  338.  
  339. procedure BoldOff;
  340.  
  341. begin
  342.   laden(3);
  343.   ausgeben;
  344. end;
  345.  
  346. procedure ItalicOn;
  347.  
  348. begin
  349.   laden(8);
  350.   ausgeben;
  351. end;
  352.  
  353. procedure ItalicOff;
  354.  
  355. begin
  356.   laden(9);
  357.   ausgeben;
  358. end;
  359.  
  360. procedure UnderLinedOn;
  361.  
  362. begin
  363.   laden(4);
  364.   ausgeben;
  365. end;
  366.  
  367. procedure UnderLinedOff;
  368.  
  369. begin
  370.   laden(5);
  371.   ausgeben;
  372. end;
  373.  
  374. procedure cr;
  375.  
  376. begin
  377.   repeat
  378.     write(lst, #13);
  379.   until getfault = 0;
  380. end;
  381.  
  382. procedure lf;
  383.  
  384. begin
  385.   repeat
  386.     write(lst, #10);
  387.   until getfault = 0;
  388. end;
  389.  
  390. procedure ff;
  391.  
  392. begin
  393.   repeat
  394.     write(lst, #12);
  395.   until getfault = 0;
  396. end;
  397.  
  398. procedure BreitOn;
  399.  
  400. begin
  401.   laden(6);
  402.   ausgeben;
  403. end;
  404.  
  405. procedure BreitOff;
  406.  
  407. begin
  408.   laden(7);
  409.   ausgeben;
  410. end;
  411.  
  412. procedure SchmalOn;
  413.  
  414. begin
  415.   laden(14);
  416.   ausgeben;
  417. end;
  418.  
  419. procedure SchmalOff;
  420.  
  421. begin
  422.   laden(15);
  423.   ausgeben;
  424. end;
  425.  
  426. procedure HighOn;
  427.  
  428. begin
  429.   laden(10);
  430.   ausgeben;
  431. end;
  432.  
  433. procedure HighOff;
  434.  
  435. begin
  436.   laden(11);
  437.   ausgeben;
  438. end;
  439.  
  440. procedure LowOn;
  441.  
  442. begin
  443.   laden(12);
  444.   ausgeben;
  445. end;
  446.  
  447. procedure LowOff;
  448.  
  449. begin
  450.   laden(13);
  451.   ausgeben;
  452. end;
  453.  
  454. function FileExists(FileName: string; attr : Word) : Boolean;
  455.  
  456. var
  457.   f: SearchRec;
  458.  
  459. begin
  460.   findfirst(Filename, attr, f);
  461.   if doserror = 0 then Fileexists := true else Fileexists := false;
  462. end;
  463.  
  464. function getpartstring(text : string; anfang, ende : char) : string;
  465.  
  466. var temp : string;
  467.     punkt : Byte;
  468.  
  469. begin
  470.   punkt := pos(anfang,text);
  471.   temp  := copy(text,punkt,length(text)-punkt);
  472.   punkt := pos(ende,temp);
  473.   temp  := copy(temp,1,punkt);
  474.   getpartstring := temp;
  475. end;
  476.  
  477. function Byte2Str(Zahl : Byte) : string;
  478.  
  479. var dummy : string;
  480.  
  481. begin
  482.   Str(Zahl,dummy);
  483.   Byte2Str := dummy;
  484. end;
  485.  
  486. begin
  487.   getIntVec($24, oldint24);
  488. end.